(** Castling the parser generator *)
(*	Copyright (C) 2008, 2009 Yuta Tomino.
	"caper" Copyright (C) 2006-2008 Naoyuki Hirayama.
	All Rights Reserved. *)

(** The signature contains token type for ParserGenerator module. *)
module type TokenType = sig
	(* include Lalr1.TOKEN;; *)
	type t;; (** Token type. *)
	val compare: t -> t -> int;; (** Compare two tokens. *)
	val eof: t;; (** The token means end of file. *)
	val invalid: t option;;
	(** The token be used to report an error.
	If invalid is None, it wraps token with option type. *)
	val pp_pattern: quali:bool -> paren:bool -> Format.formatter -> t -> unit;;
	(** Print O'Caml source for pattern matching.
	If quali is true and nessesary, print module name and dot to be used in another module.
	If paren is true and nessesary, print parenthesis.
	- [pp_pattern f ~paren:false ~quali:false (M.X 0)] prints ["X _"].
	- [pp_pattern f ~paren:false ~quali:true (M.X 1)] prints ["M.X _"].
	- [pp_pattern f ~paren:true ~quali:false (M.X 2)] prints ["(X _)"].
	- [pp_pattern f ~paren:true ~quali:true (M.X 3)] prints ["(M.X _)"]. *)

	(* additional *)

	val pp: quali:bool -> paren:bool -> Format.formatter -> t -> unit;; 
	(** Print O'Caml source to get same value.
	If quali is true and nessesary, print module name and dot to be used in another module.
	If paren is true and nessesary, print parenthesis.
	- [pp f ~paren:false ~quali:false (M.X 0)] prints ["X 0"].
	- [pp f ~paren:false ~quali:true (M.X 1)] prints ["M.X 1"].
	- [pp f ~paren:true ~quali:false (M.X 2)] prints ["(X 2)"].
	- [pp f ~paren:true ~quali:true (M.X 3)] prints ["(M.X 3)"]. *)

	val pp_typename: quali:bool -> paren:bool -> Format.formatter -> t list -> unit;;
	(** Print O'Caml source meaning the type containing values.
	If quali is true and nessesary, print module name and dot to be used in another module.
	If paren is true and nessesary, print parenthesis.
	When the parameter of values contains eof, print the type containing all extra values no used in the syntax. *)
end;;

(** This exception raised if it found invalid syntax rule. *)
exception ParserGeneratingError of string;;

(** Parser generator. *)
module ParserGenerator (Token: TokenType) = struct
	
	(** Instance of Set module with token type. *)
	module TokenSet = Set.Make (Token);;
	
	(** When [true], output internal states. 
	The initial setting for [debug] is [false]. *)
	let debug = ref false;;
	
	(** When [true], put state-numbers printing into the parser code.
	The initial setting for [runtime_debug] is [false]. *)
	let runtime_debug = ref false;;
	
	(** When [true], enable automatic error recovering.
	The initial setting for [error_handling] is [true]. *)
	let error_handling = ref true;;
	
	(** When [true], put the abstract syntax tree into polymorphic variant types.
	The initial setting for [polymorphic_variants] is [false]. *)
	let polymorphic_variants = ref false;;
	
	(** When [true], take positions as tuple having first and last positions.
	The initial setting for [ranged_position] is [false]. *)
	let ranged_position = ref false;;
	
	(** When [true], generating pretty-printer for parsed values.
	The initial setting for [pretty_printer] is [false]. *)
	let pretty_printer = ref false;;
	
	(** When [true], generating pretty-printer for errors.
	The initial setting for [error_printer] is [false]. *)
	let error_printer = ref false;;
	
	(** When [true], raise ParserGeneratingError if it found conflicting.
	The initial setting for [conflicting_error] is [true]. *)
	let conflicting_error = ref true;;
	
	(** Syntax rule representation. *)
	type tree =
		| Leaf of string * TokenSet.t
		| LeafEpsilon
		| LeafPosition
		| NodePosition of tree
		| NodePositionWith of tree
		| NodeSkip of tree
		| NodeSeq of tree list
		| NodeIndSeq of string * tree list
		| NodeOr of string * (string * tree lazy_t) list;;
	
	(** Syntax rule type. *)
	type parser = tree lazy_t;;
	
	(** Abbreviation of Lazy.force.
	It makes eager to write recursive rules.
	{[let rec rule1 = lazy !! (...use other rules...) and rule2 = lazy !! (...) and ...]} *)
	let ( !! ) = Lazy.force;;
	
	(** One token rule. *)
	let element ?(name: string = "") (e: Token.t): parser = lazy (
		Leaf (name, TokenSet.add e TokenSet.empty)
	);;
	
	(** Selecting one of tokens rule. *)
	let one_of_elements ?(name: string = "") (es: Token.t list): parser = lazy (
		Leaf (name, List.fold_right TokenSet.add es TokenSet.empty)
	);;
	
	(** Selecting one of rules, mapped to variant. *)
	let rec one_of ?(name: string = "") (ps: (string * parser) list): parser = lazy (
		NodeOr (name, ps)
	);;
	
	(** Mark name as error case for {!one_of}.
	The case used this magic name makes [None] and supresses entering on error handling.
	{[one_of "type" ["case1", ...; "case2", ...; error "error_case", ...]]} *)
	let error (name: string): string = "*" ^ name;;
	
	(** Separate sequence of rules, mapped to tuple. *)
	let sequence_of ?(name: string = "") (p: parser): parser = lazy (
		begin match Lazy.force p with
		| Leaf ("", tokens) ->
			Leaf (name, tokens)
		| NodeSeq ns
		| NodeIndSeq ("", ns) ->
			NodeIndSeq (name, ns)
		| NodeOr ("", ps) ->
			NodeOr (name, ps)
		| (_ as n) ->
			if name <> "" then (
				NodeIndSeq (name, [n])
			) else (
				n
			)
		end
	);;
	
	(** The rule be parsed, but not memorized. *)
	let skip (p: parser): parser = lazy (
		NodeSkip (Lazy.force p)
	);;
	
	(** Memorized position and syntax tree. *)
	let position_with (p: parser): parser = lazy (
		NodePositionWith (Lazy.force p)
	);;
	
	(** Memorized position only. *)
	let position_of (p: parser): parser = lazy (
		NodePosition (Lazy.force p)
	);;
	
	(** Memorized current position. *)
	let position: parser = lazy LeafPosition;;
	
	(** Empty rule. *)
	let epsilon: parser = lazy LeafEpsilon;;
	
	(** Concatenate two rules. *)
	let ( >> ) (p1: parser) (p2: parser): parser = lazy (
		begin match Lazy.force p1, Lazy.force p2 with
		| LeafEpsilon, (_ as n2) -> n2
		| (_ as n1), LeafEpsilon -> n1
		| NodeSeq s1, NodeSeq s2 -> NodeSeq (s1 @ s2)
		| NodeSeq s1, (_ as n2) -> NodeSeq (s1 @ (n2 :: []))
		| (_ as n1), NodeSeq s2 -> NodeSeq (n1 :: s2)
		| (_ as n1), (_ as n2) -> NodeSeq (n1 :: n2 :: [])
		end
	);;
	
	module Private = struct
		
		module ListEx = struct
			let rec find_first (f: 'a -> bool) (xs: 'a list): 'a list = (
				begin match xs with
				| [] -> []
				| x :: xr ->
					if f x then (
						xs
					) else (
						find_first f xr
					)
				end
			);;
		end;;
		
		let pp_ref (pp_elt: Format.formatter -> 'a -> unit) (f: Format.formatter) (x: 'a ref): unit = (
			Format.pp_print_string f "ref ";
			Format.pp_open_box f 0;
			pp_elt f !x;
			Format.pp_close_box f ()
		);;
		
		let pp_list (pp_elt: Format.formatter -> 'a -> unit) (f: Format.formatter) (xs: 'a list): unit = (
			let rec loop first xs = (
				begin match xs with
				| x :: xr ->
					if not first then (
						Format.pp_print_char f ';';
						Format.pp_print_space f ()
					);
					pp_elt f x;
					loop false xr
				| [] ->
					()
				end
			) in
			Format.pp_print_char f '[';
			Format.pp_open_box f 0;
			loop true xs;
			Format.pp_close_box f ();
			Format.pp_print_char f ']'
		);;
		
		let string_of_pp (pp: Format.formatter -> 'a -> unit) (x: 'a): string = (
			let buf = Buffer.create 256 in
			let f = Format.formatter_of_buffer buf in
			pp f x;
			Format.pp_print_flush f ();
			Buffer.contents buf
		);;
		
		module TokenMap = Map.Make (Token);;
		
		let is_error (name: string): bool = (
			String.length name > 0 && name.[0] = '*'
		);;
		
		let extract_error_name (name: string): string = (
			String.sub name 1 (String.length name - 1)
		);;
		
		let node_list (lazy p: parser): tree list = (
			let rec process (r: tree list) (t: tree): tree list = (
				if List.memq t r then r else (
					let r = t :: r in
					begin match t with
					| Leaf _ | LeafPosition | LeafEpsilon ->
						r
					| NodeSkip n | NodePosition n | NodePositionWith n ->
						process r n
					| NodeSeq ns | NodeIndSeq (_, ns) ->
						List.fold_left process r ns
					| NodeOr (_, ns) ->
						List.fold_left (fun r (_, lazy p) ->
							begin match p with
							| NodeSeq ns ->
								List.fold_left process r ns
							| _ ->
								process r p
							end
						) r ns
					end
				)
			) in
			process [] p
		);;
		
		let alphabet (ps: tree list): Token.t list = (
			let result = Token.eof :: TokenSet.elements (
				List.fold_left (fun r p ->
					begin match p with
					| Leaf (_, e) ->
						if TokenSet.mem Token.eof e then (
							raise (ParserGeneratingError ("the eof token could not be used in rules."))
						);
						begin match Token.invalid with
						| Some iv ->
							if TokenSet.mem iv e then (
								raise (ParserGeneratingError ("the unknown token could not be used in rules."))
							)
						| None ->
							()
						end;
						TokenSet.union e r
					| _ ->
						r
					end
				) TokenSet.empty ps
			) in
			begin match Token.invalid with
			| Some iv ->
				iv :: result
			| None ->
				result
			end
		);;
		
		let identifiers_of_alphabet (alphabet: Token.t list): string TokenMap.t = (
			let identifier_of_alphabet (token: Token.t): string = (
				let image = string_of_pp (Token.pp ~paren:false ~quali:false) token in
				let result = Buffer.create 32 in
				for i = 0 to String.length image - 1 do
					let c = image.[i] in
					begin match c with
					| 'A'..'Z' | 'a'..'z' | '0'..'9' -> Buffer.add_char result c
					| '_' | ' ' | '.' -> Buffer.add_char result '_'
					| '\x00'..'\x1f' | '\'' | '\"' | '`' -> ()
					| _ ->
						let hex = "0123456789abcdef" in
						let code = Char.code c in
						Buffer.add_char result '\'';
						Buffer.add_char result hex.[code lsr 4];
						Buffer.add_char result hex.[code land 15]
					end
				done;
				Buffer.contents result
			) in
			let counts = Hashtbl.create 31 in
			let map = List.fold_left (fun map token ->
				let id = identifier_of_alphabet token in
				let n = (try Hashtbl.find counts id with Not_found -> 0) in
				Hashtbl.replace counts id (n + 1);
				TokenMap.add token id map
			) TokenMap.empty alphabet in
			Hashtbl.fold (fun d_id count map ->
				if count > 1 then (
					let (_, map) = TokenMap.fold (fun token id ((count, map) as r) ->
						if id = d_id then (
							(count + 1, TokenMap.add token (id ^ String.make count '\'') map)
						) else (
							r
						)
					) map (0, map) in
					map
				) else (
					map
				)
			) counts map
		);;
		
		module Typing = struct
			
			type t = [
				| `epsilon
				| `position
				| `element of string * int ref * TokenSet.t ref
				| `tuple of string * t ref list
				| `option of t ref
				| `variant of string * (string * t ref list) list ref];;
			
			let rec pp ~(omissible: bool) ~(paren: bool) (f: Format.formatter) (t: t): unit = (
				begin match t with
				| `epsilon ->
					Format.fprintf f "`epsilon"
				| `position ->
					Format.fprintf f "`position"
				| `element (name, unique, tokens) ->
					if paren then Format.fprintf f "(@[";
					Format.fprintf f "`element (@[\"%s\",@ " (String.escaped name);
					if omissible && name <> "" then (
						Format.fprintf f "..."
					) else (
						Format.fprintf f "ref %d,@ ref (@[List.fold_right @[TokenSet.add@ %a@ TokenSet.empty@]@])"
							!unique
							(pp_list (Token.pp ~quali:false ~paren:false)) (TokenSet.elements !tokens);
					);
					Format.fprintf f "@])";
					if paren then Format.fprintf f "@])"
				| `tuple (name, ts) ->
					if paren then Format.fprintf f "(@[";
					Format.fprintf f "`tuple (@[\"%s\",@ " (String.escaped name);
					if omissible && name <> "" then (
						Format.fprintf f "..."
					) else (
						Format.fprintf f "%a"
							(pp_list (pp_ref (pp ~omissible:true ~paren:true))) ts
					);
					Format.fprintf f "@])";
					if paren then Format.fprintf f "@])"
				| `option {contents = t} ->
					if paren then Format.fprintf f "(@[";
					Format.fprintf f "`option @[%a@]" (pp ~omissible:true ~paren:true) t;
					if paren then Format.fprintf f "@])"
				| `variant (name, vs) ->
					if paren then Format.fprintf f "(@[";
					Format.fprintf f "`variant (@[\"%s\",@ " (String.escaped name);
					if omissible && name <> "" then (
						Format.fprintf f "..."
					) else (
						Format.fprintf f "ref [@[%a@]]"
							(pp_ref (pp_list (fun f (name, ts) ->
								Format.fprintf f "\"%s\",@ %a"
									(String.escaped name)
									(pp_list (pp_ref (pp ~omissible:true ~paren:true))) ts
							))) vs
					);
					Format.fprintf f "@])";
					if paren then Format.fprintf f "@])"
				end
			);;
			
			let rec merge_type (error: unit -> unit) (x: t ref) (y: t ref): unit = (
				if !x != !y then (
					begin match !x, !y with
					| `element (xname, _, xtokens), `element (yname, _, ytokens) ->
						if xname = "" && yname = "" then (
							xtokens := TokenSet.union !ytokens !xtokens;
							y := !x
						) else if xname <> yname then (
							error ()
						)
					| `tuple (xname, xts), `tuple (yname, yts) ->
						if xname = "" && yname = "" then (
							x := `tuple (xname, (merge_type_list "" xts yts));
							y := !x
						) else if xname <> yname then (
							error ()
						)
					| `variant (xname, xvs), `variant (yname, yvs) ->
						if xname = "" && yname = "" then (
							xvs := merge_variants "" !xvs !yvs;
							y := !x
						) else if xname <> yname then (
							error ()
						)
					| `option xt, `option yt ->
						merge_type error xt yt;
						y := !x
					| _ ->
						error ()
					end
				)
			) and merge_type_list (name: string) (xs: t ref list) (ys: t ref list): t ref list = (
				begin try
					let error () = (
						raise (ParserGeneratingError ("sequence rules of \"" ^ name ^ "\" were different."))
					) in
					List.fold_right2 (fun x y rs -> merge_type error x y; x :: rs) xs ys []
				with Invalid_argument _ ->
					raise (ParserGeneratingError ("sequence rules of \"" ^ name ^ "\" were different."))
				end
			) and merge_variants (name: string) (xs: (string * t ref list) list) (ys: (string * t ref list) list): (string * t ref list) list = (
				begin try
					let shared = List.filter (fun (n, _) -> n <> "" && List.mem_assoc n ys) xs in
					let merged_shared = (
						List.map (fun (n, xs) ->
							let ys = List.assoc n ys in
							(n, (merge_type_list n xs ys))
						) shared
					) in
					let not_shared (n, _) = not (List.mem_assoc n shared) in
					let not_shared_xs = List.filter not_shared xs in
					let not_shared_ys = List.filter not_shared ys in
					merged_shared @ not_shared_xs @ not_shared_ys
				with Invalid_argument _ ->
					raise (ParserGeneratingError ("variant rules of \"" ^ name ^ "\" were different."))
				end
			);;
			
			(* make map of tree -> type *)
			let node_map (ps: tree list): (tree * t ref) list = (
				List.map (fun p -> p, ref `epsilon) ps
			);;
			
			(* fill types *)
			let fill_type_graph (map: (tree * t ref) list): t ref list = (
				List.fold_left (fun rs (p, t) ->
					begin match p with
					| LeafEpsilon | NodeSkip _ ->
						t := `epsilon;
						t :: rs
					| Leaf (name, tokens) ->
						t := `element (name, ref 0, ref tokens);
						t :: rs
					| LeafPosition | NodePosition _ ->
						t := `position;
						t :: rs
					| NodePositionWith n ->
						let pt = ref `position in
						t := `tuple ("", [pt; List.assq n map]);
						t :: pt :: rs
					| NodeSeq ns ->
						let tt = ref (`tuple ("", List.map (fun n -> List.assq n map) ns)) in
						t := `option tt;
						t :: tt :: rs
					| NodeIndSeq (name, ns) ->
						let tt = ref (`tuple (name, List.map (fun n -> List.assq n map) ns)) in
						t := `option tt;
						t :: tt :: rs
					| NodeOr (name, vs) ->
						t := `variant (name, ref (List.fold_left (fun rs (sel_name, lazy p) ->
							if is_error sel_name then rs else
							(sel_name, (match p with
								| NodeSeq ns ->
									List.map (fun n -> List.assq n map) ns
								| _ -> [List.assq p map])) :: rs) [] vs));
						t :: rs
					end
				) [] map
			);;
			
			(* remove epsilons from list, and empty tuple to epsilon, and remove ... *)
			let remove_epsilons (ts: t ref list): unit = (
				let rec loop all_ts ts changed = (
					begin match ts with
					| [] ->
						if changed then (
							loop all_ts all_ts false
						)
					| t :: tr ->
						let new_changed = (
							begin match !t with
							| `tuple (name, rs) ->
								if List.exists (fun {contents = r} -> r = `epsilon) rs then (
									let rs2 = List.filter (fun {contents = r} -> r <> `epsilon) rs in
									begin match rs2 with
									| [] when name = "" ->
										t := `epsilon
									| [single_t] when name = "" ->
										t := !single_t
									| _ ->
										t := `tuple (name, rs2)
									end;
									true
								) else (
									changed
								)
							| `variant (name, {contents = vs}) ->
								let vs2, current_changed = (
									List.fold_left (fun (vs2, current_changed) ((v_name, rs) as v) ->
										if List.exists (fun {contents = r} -> r = `epsilon) rs then (
											let rs2 = List.filter (fun {contents = r} -> r <> `epsilon) rs in
											((v_name, rs2) :: vs2), true
										) else (
											(v :: vs2), current_changed
										)
									) ([], false) vs
								) in
								if current_changed then (
									t := `variant (name, ref vs2);
									true
								) else (
									changed
								)
							| `option {contents = r} ->
								begin match r with
								| `tuple _ ->
									changed
								| _ ->
									t := r;
									true
								end
							| `epsilon | `position | `element _ ->
								changed
							end
						) in
						loop all_ts tr new_changed
					end
				) in
				loop ts ts false
			);;
			
			(* unify types having same name *)
			let unify_named_types (ts: t ref list): unit = (
				let error (typename: string): unit = (
					raise (ParserGeneratingError ("types named \"" ^ typename ^ "\" were different."))
				) in
				let rec loop (processed: string list) (xs: t ref list): unit = (
					begin match xs with
					| x :: xr ->
						begin match !x with
						| `element (xname, _, xtokens) when not (List.mem xname processed) ->
							List.iter (fun y ->
								begin match !y with
								| `element (yname, _, ytokens) when yname = xname ->
									xtokens := TokenSet.union !ytokens !xtokens;
									y := !x
								| `tuple (yname, _) | `variant (yname, _) when yname = xname -> error xname
								| _ -> ()
								end
							) xs;
							loop (xname :: processed) xr
						| `tuple (xname, xts) when not (List.mem xname processed) ->
							List.iter (fun y ->
								begin match !y with
								| `tuple (yname, yts) when yname = xname ->
									x := `tuple (xname, (merge_type_list xname xts yts));
									y := !x
								| `element (yname, _, _) | `variant (yname, _) when yname = xname -> error xname
								| _ -> ()
								end
							) xs;
							loop (xname :: processed) xr
						| `variant (xname, xvs) when not (List.mem xname processed) ->
							List.iter (fun y ->
								begin match !y with
								| `variant (yname, yvs) when yname = xname ->
									xvs := merge_variants xname !yvs !xvs;
									y := !x
								| `element (yname, _, _) | `tuple (yname, _) when yname = xname -> error xname
								| _ -> ()
								end
							) xs;
							loop (xname :: processed) xr
						| _ ->
							loop processed xr
						end;
					| [] -> ()
					end
				) in
				loop [""] ts
			);;
			
			(* expand variants *)
			let expand_variants (ts: t ref list): unit = (
				let rec check_bad_variant (ts: t ref list): unit = (
					begin match ts with
					| t :: tr ->
						begin match !t with
						| `variant (typename, vs) ->
							List.iter (fun v ->
								begin match v with
								| "", _ :: [] -> ()
								| "", _ -> raise (ParserGeneratingError ("recursive rule of \"" ^ typename ^ "\" is invalid form."))
								| _ -> ()
								end
							) !vs
						| _ ->
							()
						end;
						check_bad_variant tr
					| [] ->
						()
					end
				) in
				let rec unify_tags (ts: t ref list): unit = (
					begin match ts with
					| t :: tr ->
						begin match !t with
						| `variant (_, vs) ->
							vs := (
								List.fold_left (fun rs ((tagname, ts) as item) ->
									if List.mem_assoc tagname rs then (
										let r_ts = List.assoc tagname rs in
										(tagname, merge_type_list tagname ts r_ts) :: List.remove_assoc tagname rs
									) else (
										item :: rs
									)
								) [] !vs
							)
						| _ ->
							()
						end;
						unify_tags tr
					| [] ->
						()
					end
				) in
				let rec loop_1 (all: t ref list) (ts: t ref list) (changed: bool): unit = (
					begin match ts with
					| t :: tr ->
						begin match !t with
						| `variant (_, vs) ->
							let (new_vs, new_changed) = (
								List.fold_left (fun (rs, new_changed) v ->
									begin match v with
									| "", [t2] when !t2 == !t -> rs, true
									| _ -> v :: rs, new_changed
									end
								) ([], changed) !vs
							) in
							vs := new_vs;
							loop_1 all tr new_changed
						| _ ->
							loop_1 all tr changed
						end
					| [] ->
						loop_2 all all changed
					end
				) and loop_2 (all: t ref list) (ts: t ref list) (changed: bool): unit = (
					begin match ts with
					| t :: tr ->
						begin match !t with
						| `variant (name, vs) ->
							let rec loop_f vs rs new_changed = (
								begin match vs with
								| v :: vr ->
									begin match v with
									| "", [{contents = `variant (_, vs2)}] ->
										let new_vs = merge_variants name (List.rev_append vr rs) !vs2 in
										loop_f new_vs [] true
									| _ ->
										loop_f vr (v :: rs) new_changed
									end
								| [] ->
									rs, new_changed
								end
							) in
							let (new_vs, new_changed) = loop_f !vs [] changed in
							vs := new_vs;
							loop_2 all tr new_changed
						| _ ->
							loop_2 all tr changed
						end
					| [] ->
						if changed then loop_1 all all false
					end
				) in
				check_bad_variant ts;
				unify_tags ts;
				loop_1 ts ts false
			);;
			
			let string_of_token_typename (tokens: Token.t list): string = (
				string_of_pp (Token.pp_typename ~paren:false ~quali:false) tokens
			);;
			
			(* unify types having same structure *)
			let unify_anonymous_types (ts: t ref list): unit = (
				let rec unify_elements (ts: t ref list): unit = (
					begin match ts with
					| t :: tr ->
						begin match !t with
						| `element ("", _, tt) ->
							let rec loop t xs = (
								begin match xs with
								| x :: xr ->
									begin match !x with
									| `element ("", _, xt) ->
										if !x != !t &&
											string_of_token_typename (TokenSet.elements !xt) =
											string_of_token_typename (TokenSet.elements !tt)
										then (
											x := !t
										)
									| _ ->
										()
									end;
									loop t xr
								| [] ->
									()
								end
							) in
							loop t tr;
						| _ ->
							()
						end;
						unify_elements tr
					| [] ->
						()
					end
				) in
				let rec same_typelist (xs: t ref list) (ys: t ref list): bool = (
					begin match xs, ys with
					| x :: xr, y :: yr when !x == !y -> same_typelist xr yr
					| [], [] -> true
					| _, _ -> false
					end
				) in
				let rec unify_composed (all: t ref list) (changed: bool) (ts: t ref list): unit = (
					begin match ts with
					| t :: tr ->
						let changed = (
							begin match !t with
							| `tuple ("", t_items) ->
								let rec loop t t_items changed xs = (
									begin match xs with
									| x :: xr ->
										let changed = (
											begin match !x with
											| `tuple ("", x_items) ->
												if !x != !t && same_typelist x_items t_items then (
													x := !t;
													true
												) else (
													changed
												)
											| _ ->
												changed
											end
										) in
										loop t t_items changed xr
									| [] ->
										changed
									end
								) in
								loop t t_items changed tr;
							| `option tt ->
								let rec loop t tt changed xs = (
									begin match xs with
									| x :: xr ->
										let changed = (
											begin match !x with
											| `option xt ->
												if !x != !t && !xt == !tt then (
													x := !t;
													true
												) else (
													changed
												)
											| _ ->
												changed
											end
										) in
										loop t tt changed xr
									| [] ->
										changed
									end
								) in
								loop t tt changed tr;
							| _ ->
								changed
							end
						) in
						unify_composed all changed tr
					| [] ->
						if changed then unify_composed all false all
					end
				) in
				unify_elements ts;
				unify_composed ts false ts
			);;
			
			let unique_types (ts: t ref list): t list = (
				let rec loop ts rs = (
					begin match ts with
					| {contents = t} :: tr ->
						if List.memq t rs then (
							loop tr rs
						) else (
							loop tr (t :: rs)
						)
					| [] ->
						rs
					end
				) in
				loop ts []
			);;
			
			let number_anonymous_elements (ts: t list): unit = (
				let rec extract_elements ts rs = (
					begin match ts with
					| t :: tr ->
						let rs = (
							match t with
							| `element ("", _, _) when not (List.memq t rs) -> (t :: rs)
							| _ -> rs
						) in
						extract_elements tr rs
					| [] ->
						rs
					end
				) in
				let es = extract_elements ts [] in
				let num = List.length es in
				if num >= 2 then (
					let rec loop es n = (
						begin match es with
						| e :: er ->
							begin match e with
							| `element ("", unique, _) -> unique := n;
							| _ -> assert false
							end;
							loop er (n - 1)
						| [] ->
							()
						end
					) in
					loop es num
				)
			);;
			
			let rec sort_tags (types: t list): unit = (
				begin match types with
				| t :: tr ->
					begin match t with
					| `variant (_, vs) ->
						let compare_tag (x, _) (y, _) = String.compare x y in
						vs := List.sort compare_tag !vs
					| _ -> ()
					end;
					sort_tags tr
				| [] ->
					()
				end
			);;
			
			let check_types_on_normal_variants (ts: t list): unit = (
				let rec loop (ts: t list) (vs: (string * string) list): unit = (
					begin match ts with
					| t :: tr ->
						let vs = (
							begin match t with
							| `variant ("", _) ->
								raise (ParserGeneratingError ("anonymous variants are not allowed. please, set polymorphic_variants to true."))
							| `variant (tname, {contents = xs}) ->
								let rec vloop xs vs = (
									begin match xs with
									| (vname, _) :: xr ->
										if List.exists (fun (tn, vn) -> tn <> tname && vn = vname) vs then (
											raise (ParserGeneratingError ("constructor \"" ^ vname ^ "\" exists in different rules. please, set polymorphic_variants to true."))
										);
										vloop xr ((tname, vname) :: vs)
									| [] ->
										vs
									end
								) in
								vloop xs vs
							| _ ->
								vs
							end
						) in
						loop tr vs
					| [] ->
						()
					end
				) in
				loop ts []
			);;
			
			let types_of_parser (ps: tree list): t list * (tree * t) list = (
				let map = node_map ps in
				let types = fill_type_graph map in
				remove_epsilons types;
				unify_named_types types;
				expand_variants types;
				unify_anonymous_types types;
				let unique_types = unique_types types in
				number_anonymous_elements unique_types;
				sort_tags unique_types;
				if not !polymorphic_variants then check_types_on_normal_variants unique_types;
				let map = List.map (fun (p, {contents = t}) -> p, t) map in
				unique_types, map
			);;
			
			let rec first_type_for_error (t: t): t = (
				begin match t with
				| `epsilon | `position | `element _ | `variant _ -> t
				| `option x -> first_type_for_error !x
				| `tuple (name, xs) ->
					if name <> "" then t else
					let rec loop (xs: t ref list): t = (
						begin match xs with
						| [] -> `epsilon
						| x :: xr ->
							begin match first_type_for_error !x with
							| `epsilon | `position -> loop xr
							| (`element _ as r) | (`variant _ as r) | (`tuple _ as r) -> r
							| `option _ -> assert false
							end
						end
					) in
					loop xs
				end
			);;
			
			let is_polymorphic_variant (alphabet: Token.t list): bool = (
				begin match alphabet with
				| a :: b :: _ ->
					let a_image = string_of_token_typename [a] in
					let b_image = string_of_token_typename [b] in
					a_image <> b_image
				| _ ->
					false
				end
			);;
			
		end;;
		
		module SemanticAction = struct
			
			type t =
				| Token of Typing.t
				| PositionAt (* current position *)
				| PositionWith of Typing.t * Typing.t (* result type, original type *)
				| Tuple of Typing.t * (int * (bool * Typing.t)) list
				| Variant of Typing.t * string * (int * (bool * Typing.t)) list
				| Itself of Typing.t * int
				| Any of string;; (* temporary *)
			
			let get_type (x: t): Typing.t = (
				begin match x with
				| Token t | Variant (t, _, _) | Itself (t, _) | Tuple (t, _)
				| PositionWith (t, _) -> t
				| PositionAt -> `position
				| Any _ -> assert false
				end
			);;
			
			let compare (x: t) (y: t): int = (
				let compare_type (x: Typing.t) (y: Typing.t): int = (
					Obj.magic x - Obj.magic y
				) in
				let rec compare_items (xs: (int * (bool * Typing.t)) list) (ys: (int * (bool * Typing.t)) list): int = (
					begin match xs, ys with
					| (xi, (xp, xt)) :: xr, (yi, (yp, yt)) :: yr ->
						let r = xi - yi in
						if r <> 0 then r else
						let r = (Pervasives.compare: bool -> bool -> int) xp yp in
						if r <> 0 then r else
						let r = compare_type xt yt in
						if r <> 0 then r else
						compare_items xr yr
					| [], [] -> 0
					| [], _ -> -1
					| _, [] -> 1
					end
				) in
				begin match x, y with
				| Token xt, Token yt ->
					compare_type xt yt
				| PositionAt, PositionAt ->
					0
				| PositionWith (xt, xe), PositionWith (yt, ye) ->
					let r = compare_type xt yt in if r <> 0 then r else
					compare_type xe ye
				| Tuple (xt, xl), Tuple (yt, yl) ->
					let r = compare_type xt yt in if r <> 0 then r else
					compare_items xl yl
				| Variant (xt, xc, xl), Variant (yt, yc, yl) ->
					let r = compare_type xt yt in if r <> 0 then r else
					let r = String.compare xc yc in if r <> 0 then r else
					compare_items xl yl
				| Itself (xt, xi), Itself (yt, yi) ->
					let r = xi - yi in if r <> 0 then r else
					compare_type xt yt
				| Any xm, Any ym ->
					String.compare xm ym
				| _ ->
					let index (x: t): int = (
						begin match x with
						| Token _ -> 0
						| PositionAt -> 1
						| PositionWith _ -> 2
						| Tuple _ -> 3
						| Variant _ -> 4
						| Itself _ -> 5
						| Any _ -> 6
						end
					) in
					let r = index x - index y in
					assert (r <> 0);
					r
				end
			);;
			
			let is_error (x: t): bool = (
				begin match x with
				| Variant (_, name, _) -> is_error name
				| _ -> false
				end
			);;
			
			let get_indexes (x: t): (int * (bool * Typing.t)) list = (
				begin match x with
				| Token t -> [(0, (false, t))]
				| PositionAt -> [(0, (true, `position))]
				| PositionWith (t, _) -> [(0, (true, t))]
				| Tuple (_, indexes) | Variant (_, _, indexes) -> indexes
				| Itself (t, p) -> [(p, (false, t))]
				| Any _ -> []
				end
			);;
			
			let pp (f: Format.formatter) (x: t): unit = (
				let string_of_indexes ls = (
					List.fold_left (fun r (i, _) ->
						(if r <> "" then r ^ ", " else "") ^ string_of_int i
					) "" ls
				) in
				begin match x with
				| Token _ -> Format.fprintf f "token"
				| PositionAt -> Format.fprintf f "position"
				| PositionWith (`position, _) -> Format.fprintf f "position of"
				| PositionWith _ -> Format.fprintf f "position with"
				| Tuple (_, indexes) -> Format.fprintf f "tuple of (%s)" (string_of_indexes indexes)
				| Variant (_, name, indexes) -> Format.fprintf f "%s(%s)" name (string_of_indexes indexes)
				| Itself _ -> Format.fprintf f "itself"
				| Any message -> Format.fprintf f "%s" message
				end
			);;
			
		end;;
		
		module Lalr1 = Lalr1.Make (Token) (SemanticAction);;
		
		let rules_of_parser (p: parser) (map: (tree * Typing.t) list): Lalr1.rule array * string array = (
			let result = ref [] in
			let processed = ref [] in
			let nonterminal_number = ref 1 in
			let rec process (t: tree): int = (
				begin match ListEx.find_first (fun (a, _) -> a == t) !processed with
				| (_, it) :: _ -> it
				| [] ->
					let get_number (): int = (
						let result = !nonterminal_number in
						incr nonterminal_number;
						result
					) in
					let map_single (n: tree): Lalr1.symbol = (
						begin match n with
						| Leaf (_, es) | NodePosition (Leaf (_, es)) | NodePositionWith (Leaf (_, es))
						| NodeSkip (Leaf (_, es)) when TokenSet.cardinal es = 1 ->
							Lalr1.Terminal (TokenSet.choose es)
						| NodePosition m | NodePositionWith m ->
							Lalr1.Nonterminal (process m)
						| _ ->
							Lalr1.Nonterminal (process n)
						end
					) in
					let map_sequence (ns: tree list): Lalr1.symbol array = (
						Array.of_list (List.map map_single ns)
					) in
					let get_indexes (ns: tree list): (int * (bool * Typing.t)) list = (
						let rec loop i ns rs = (
							begin match ns with
							| n :: nr ->
								begin match n with
								| LeafEpsilon | NodeSkip _ ->
									loop (i + 1) nr rs
								| NodePosition _ ->
									loop (i + 1) nr ((i, (true, `position)) :: rs)
								| NodePositionWith n ->
									loop (i + 1) nr ((i, (true, List.assq n map)) :: rs)
								| Leaf _ | LeafPosition | NodeOr _ | NodeIndSeq _ | NodeSeq _ ->
									loop (i + 1) nr ((i, (false, List.assq n map)) :: rs)
								end
							| [] -> List.rev rs
							end
						) in
						loop 0 ns []
					) in
					begin match t with
					| Leaf (_, es) ->
						let number = get_number () in
						processed := (t, number) :: !processed;
						TokenSet.iter (fun e ->
							let sa = SemanticAction.Token (List.assq t map) in
							let new_rule = {
								Lalr1.left = number;
								Lalr1.elements = [|Lalr1.Terminal e|];
								Lalr1.semantic_action = sa}
							in
							result := new_rule :: !result
						) es;
						number
					| LeafEpsilon ->
						let number = get_number () in
						processed := (t, number) :: !processed;
						let sa = SemanticAction.Any "epsilon" in
						let new_rule = {
							Lalr1.left = number;
							Lalr1.elements = [| |];
							Lalr1.semantic_action = sa}
						in
						result := new_rule :: !result;
						number
					| LeafPosition ->
						let number = get_number () in
						processed := (t, number) :: !processed;
						let new_rule = {
							Lalr1.left = number;
							Lalr1.elements = [| |];
							Lalr1.semantic_action = SemanticAction.PositionAt}
						in
						result := new_rule :: !result;
						number
					| NodePosition n ->
						let number = get_number () in
						processed := (t, number) :: !processed;
						let sa = SemanticAction.PositionWith (`position, List.assq n map) in
						let new_rule = {
							Lalr1.left = number;
							Lalr1.elements = [|map_single n|];
							Lalr1.semantic_action = sa}
						in
						result := new_rule :: !result;
						number
					| NodePositionWith n ->
						let number = get_number () in
						processed := (t, number) :: !processed;
						let sa = SemanticAction.PositionWith (List.assq t map, List.assq n map) in
						let new_rule = {
							Lalr1.left = number;
							Lalr1.elements = [|map_single n|];
							Lalr1.semantic_action = sa}
						in
						result := new_rule :: !result;
						number
					| NodeSkip n ->
						process n
					| NodeSeq ns | NodeIndSeq (_, ns) ->
						let number = get_number () in
						processed := (t, number) :: !processed;
						let indexes = get_indexes ns in
						let sa = (
							begin match indexes with
							| (index, (false, typ)) :: [] ->
								SemanticAction.Itself (typ, index)
							| _ ->
								SemanticAction.Tuple (List.assq t map, indexes)
							end
						) in
						let new_rule = {
							Lalr1.left = number;
							Lalr1.elements = map_sequence ns;
							Lalr1.semantic_action = sa}
						in
						result := new_rule :: !result;
						number
					| NodeOr (_, ns) ->
						let number = get_number () in
						processed := (t, number) :: !processed;
						List.iter (fun (ctor, n) ->
							let sa indexes = (
								if ctor = "" then (
									assert (List.length indexes = 1);
									let (idx, (_, typ)) = List.hd indexes in
									SemanticAction.Itself (typ, idx)
								) else (
									SemanticAction.Variant (List.assq t map, ctor, indexes)
								)
							) in
							let n = Lazy.force n in
							let ns = (
								match n with
								| NodeSeq ns -> ns
								| LeafEpsilon -> []
								| _ -> [n]
							) in
							let indexes = get_indexes ns in
							let new_rule = {
								Lalr1.left = number;
								Lalr1.elements = map_sequence ns;
								Lalr1.semantic_action = sa indexes}
							in
							result := new_rule :: !result
						) ns;
						number
					end
				end
			) in
			let start = process (Lazy.force p) in
			let rec name_of ?(number: int = -1) (t: tree): string = (
				let n = (
					match t with
					| Leaf _ -> "element"
					| LeafEpsilon -> "epsilon"
					| LeafPosition -> "position"
					| NodePosition n -> "p(" ^ name_of n ^ ")"
					| NodePositionWith n -> "w(" ^ name_of n ^ ")"
					| NodeSkip n -> "s(" ^ name_of n ^ ")"
					| NodeSeq _ | NodeIndSeq _ -> "tuple"
					| NodeOr (typename, _) -> typename
				) in
				if number >= 0 then n ^ "@" ^ string_of_int number else n
			) in
			let nonterminal_names = Array.of_list ("root@0" ::
				(List.map (fun (t, i) -> name_of ~number:i t) (List.rev !processed)))
			in
			let rules = !result in
			let root_rule = {Lalr1.left = 0;
				Lalr1.elements = [|Lalr1.Nonterminal start|];
				Lalr1.semantic_action = SemanticAction.Any "accept"} in
			let result_rules = Array.of_list (root_rule :: rules) in
			result_rules, nonterminal_names
		);;
		
		let correct_bad_names (rules: Lalr1.rule array): string list = (
			let rec loop rules i rs = (
				if i >= Array.length rules then (
					rs
				) else (
					let {Lalr1.semantic_action = sa} = rules.(i) in
					let rs = (
						match sa with
						| SemanticAction.Variant (_, name, _) when is_error name ->
							let n = extract_error_name name in
							if List.mem n rs then rs else n :: rs
						| _ -> rs
					) in
					loop rules (i + 1) rs
				)
			) in
			loop rules 0 []
		);;
		
		let correct_symbols_on_error (table: Lalr1.table): Token.t list * (Typing.t * bool) list = (
			let expected_terminals = ref TokenSet.empty in
			let expected_nonterminals = ref [] in
			let states = Lalr1.states table in
			for i = 0 to Array.length states - 1 do
				let action_table = Lalr1.action_table states.(i) in
				Lalr1.TokenMap.iter (fun _ (_, action) ->
					begin match action with
					| Lalr1.ErrorShiftTerminal (tokens, _) ->
						expected_terminals := TokenSet.union tokens !expected_terminals
					| Lalr1.ErrorShiftNonterminal (tokens, semantic_action, optional, _) ->
						let first_type = Typing.first_type_for_error (SemanticAction.get_type semantic_action) in
						begin match first_type with
						| `element _ ->
							expected_terminals := TokenSet.union tokens !expected_terminals
						| _ ->
							if List.for_all (fun (t, o) -> t != first_type || o <> optional) !expected_nonterminals then (
								expected_nonterminals := (first_type, optional) :: !expected_nonterminals
							)
						end
					| Lalr1.ErrorReduce _ | Lalr1.Shift _ | Lalr1.Reduce _ | Lalr1.Accept -> ()
					end
				) action_table
			done;
			(TokenSet.elements !expected_terminals), !expected_nonterminals
		);;
		
		module Writer = struct
			open Format;;
			
			let output_header (f: formatter) (alphabet: Token.t list): unit = (
				fprintf f "@[<hv0>@[<hv3>(* - generated by castling -";
				if alphabet <> [] then (
					fprintf f "@ @[<b10>alphabet: ";
					let (_: bool) = List.fold_left (fun first e ->
						if not first then fprintf f ",@ ";
						Token.pp_pattern ~quali:false ~paren:false f e;
						false
					) true alphabet in
					fprintf f "@]"
				);
				fprintf f " *)@]@,"
			);;
			
			let output_footer (f: formatter) (): unit = (
				fprintf f "@]@?"
			);;
			
			let begin_module (f: formatter) (name: string): unit = (
				fprintf f "@ @[<hv0>@[<b2>module@ %s@ =@ struct@,@[<hv0>" name
			);;
			
			let end_module (f: formatter) (): unit = (
				fprintf f "@]@]@ end;;@]@,"
			);;
			
			let open_module (f: formatter) (name: string): unit = (
				fprintf f "@[<b2>open@ %s;;@]@," name
			);;
			
			let output_single_position_typename (f: formatter) (): unit = (
				fprintf f "'p"
			);;
			
			let output_position_typename ~(paren:bool) (f: formatter) (): unit = (
				if !ranged_position then (
					if paren then fprintf f "(";
					output_single_position_typename f ();
					fprintf f " * ";
					output_single_position_typename f ();
					if paren then fprintf f ")"
				) else (
					output_single_position_typename f ()
				)
			);;
			
			let rec output_typename ~(option: bool) (f: formatter) (t: Typing.t) = (
				begin match t with
				| `element (name, _, tokens) ->
					if name <> "" then (
						fprintf f "%s" name
					) else (
						let es = (
							let es = TokenSet.elements !tokens in
							begin match Token.invalid with
							| Some iv ->
								iv :: es
							| None ->
								es
							end
						) in
						Token.pp_typename ~quali:true ~paren:option f es
					);
					if option && Token.invalid = None then fprintf f " option"
				| `tuple (name, ts) ->
					if name = "" then (
						fprintf f "(@[";
						let (_: bool) = List.fold_left (fun first {contents = e} ->
							if not first then fprintf f " *@ ";
							output_typename ~option:true f e;
							false
						) true ts in
						fprintf f "@])"
					) else (
						fprintf f "%s" name
					)
				| `option {contents = t} ->
					output_typename ~option:false f t;
					if option then fprintf f " option"
				| `variant (name, _) ->
					assert (name <> "");
					output_single_position_typename f ();
					fprintf f " %s" name;
					if option then fprintf f " option"
				| `position ->
					output_position_typename ~paren:option f ()
				| `epsilon ->
					assert false
				end
			);;
			
			let output_result_types (f: formatter) (ts: Typing.t list): unit = (
				if not (
					List.fold_left (fun first e ->
						begin match e with
						| (`element (name, _, _) as e)
						| (`variant (name, _) as e) when name <> "" ->
							if first then (
								fprintf f "@ @[<hv0>@[<hv2>@[<b2>type@ "
							) else (
								fprintf f "@ @[<hv2>@[<b2>and@ "
							);
							output_typename f ~option:false e;
							fprintf f "@ =@]";
							begin match e with
							| `element (_, _, tokens) ->
								fprintf f "@ ";
								Token.pp_typename ~quali:true ~paren:false f (TokenSet.elements !tokens)
							| `variant (_, {contents = items}) ->
								let (_: bool) = List.fold_left (fun first (nn, nt) ->
									if nn <> "" then (
										if first then (
											fprintf f "@;<1 2>@[<b2>"
										) else (
											fprintf f "@ @[<b4>|@ "
										);
										fprintf f "%s" (String.capitalize nn);
										begin match nt with
										| [] -> ()
										| [{contents = t}] ->
											fprintf f "@ of@ ";
											output_typename f ~option:true t
										| ts ->
											fprintf f "@ of@ (";
											let (_: bool) = List.fold_left (fun first {contents = t} ->
												if not first then (
													fprintf f " *@ "
												);
												output_typename f ~option:true t;
												false
											) true ts in
											fprintf f ")"
										end;
										fprintf f "@]";
										false
									) else (
										first
									)
								) true items in ()
							end;
							fprintf f "@]";
							false
						| _ ->
							first
						end
					) true ts
				) then (
					fprintf f ";;@]@,"
				)
			);;
			
			let rec output_ctorname (f: formatter) (t: Typing.t): unit = (
				begin match t with
				| `element (name, unique, _) ->
					if !unique <> 0 then (
						fprintf f "%d" !unique
					) else if name = "" then (
						fprintf f "elt"
					) else (
						fprintf f "%s" name
					)
				| `tuple (name, ts) ->
					if name = "" then (
						fprintf f "B";
						List.iter (fun {contents = t} ->
							fprintf f "_";
							output_ctorname f t
						) ts;
						fprintf f "_E"
					) else (
						fprintf f "%s" name
					)
				| `option {contents = `tuple ("", _) as x} ->
					output_ctorname f x;
					fprintf f "o"
				| `option {contents = t} ->
					output_ctorname f t
				| `variant (name, _) ->
					fprintf f "%s" name
				| `epsilon ->
					fprintf f "unit"
				| `position ->
					fprintf f "position"
				end
			);;
			
			let rec output_printer_name (f: formatter) (t: Typing.t): unit = (
				begin match t with
				| `position when !ranged_position ->
					fprintf f "pp_position_pair pp_position"
				| `element ("", _, _) ->
					fprintf f "pp_elt"
				| _ ->
					fprintf f "pp_";
					let t = (
						match t with
						| `option {contents = t} -> t
						| _ -> t
					) in
					output_ctorname f t
				end
			);;
			
			let output_pretty_printer (f: formatter)
				(alphabet: Token.t list) (ts: Typing.t list): unit =
			(
				let process (first: bool) (t: Typing.t): unit = (
					let pp_sequence (nt: Typing.t ref list): unit = (
						let call_pp ~(paren: bool) (t: Typing.t) (index: int): unit = (
							fprintf f "@,@[<b2>";
							let opt = (
								match t with
								| `variant _ -> true
								| `element _ -> Token.invalid = None
								| `tuple _ -> false
								| `option _ -> true
								| `position -> false
								| `epsilon -> assert false
							) in
							if opt then fprintf f "pp_option@ ";
							begin match t with
							| `variant _ | `tuple _ | `option _ -> 
								if opt then fprintf f "(";
								output_printer_name f t;
								fprintf f "@ pp_elt@ pp_position";
								if opt then fprintf f ")"
							| `element _ | `position | `epsilon ->
								output_printer_name f t
							end;
							if opt then fprintf f "@ ~paren:%b" paren;
							fprintf f "@ f@ ";
							let downcast = (
								match t with
								| `element (_, _, tokens) -> Typing.string_of_token_typename (TokenSet.elements !tokens) <> Typing.string_of_token_typename alphabet
								| _ -> false
							) in
							if downcast then fprintf f "(";
							fprintf f "a%d" index;
							if downcast then (
								fprintf f ":> %a" (Token.pp_typename ~quali:true ~paren:true) alphabet;
								if Token.invalid = None then fprintf f " option";
								fprintf f ")"
							);
							fprintf f "@]"
						) in
						begin match nt with
						| [] -> ()
						| {contents = t} :: [] ->
							call_pp ~paren:true t 1
						| ts ->
							fprintf f "@,Format.pp_open_box f 2;@,";
							fprintf f "Format.pp_print_string f \"(\";";
							let (_: int) = List.fold_left (fun i {contents = t} ->
								if i > 1 then (
									fprintf f ";@,Format.pp_print_char f \',\';@,";
									fprintf f "Format.pp_print_space f ();"
								);
								call_pp ~paren:false t i;
								succ i
							) 1 ts in
							fprintf f ";@,Format.pp_print_string f \")\";@,";
							fprintf f "Format.pp_close_box f ()"
						end
					) in
					if first then (
						fprintf f "@ @[<hv0>@[<hv2>@[<b4>let rec "
					) else (
						fprintf f "@,@[<hv2>@[<b4>and "
					);
					output_printer_name f t;
					fprintf f "@ (pp_elt: Format.formatter -> ";
					Token.pp_typename f ~quali:true ~paren:false alphabet;
					fprintf f " -> unit)@ (pp_position: Format.formatter -> 'p -> unit)@ (f: Format.formatter)@ (v: ";
					output_typename f ~option:false t;
					fprintf f ") =@]@,";
					begin match t with
					| `variant (_, items) ->
						fprintf f "@[match @[v@]@ with@]";
						let (_: bool) = List.fold_left (fun first (nn, nt) ->
							if nn <> "" then (
								if first then (
									fprintf f "@;<1 2>@[<b2>@[<hov-2>"
								) else (
									fprintf f "@ | @[<b2>@[<hov-2>"
								);
								let capitalized_tag = String.capitalize nn in
								fprintf f "%s" capitalized_tag;
								begin match nt with
								| [] -> ()
								| _ :: [] ->
									fprintf f " a1"
								| ts ->
									fprintf f " (";
									let (_: int) = List.fold_left (fun i _ ->
										if i > 1 then fprintf f ", ";
										fprintf f "a%d" i;
										succ i
									) 1 ts in
									fprintf f ")"
								end;
								fprintf f " ->@]@ @[<hv>";
								if nt <> [] then (
									fprintf f "Format.pp_open_box f 2;@,";
									fprintf f "Format.pp_print_string f \"(%s\";@," capitalized_tag
								) else (
									fprintf f "Format.pp_print_string f \"%s\";@," capitalized_tag
								);
								if nt <> [] then (
									fprintf f "Format.pp_print_space f ();";
									pp_sequence nt;
									fprintf f ";@,Format.pp_print_string f \")\";@,";
									fprintf f "Format.pp_close_box f ()"
								);
								fprintf f "@]@]";
								false
							) else (
								first
							)
						) true !items in ()
					| `tuple (_, nt) ->
						fprintf f "let ";
						let (_: int) = List.fold_left (fun i _ ->
							if i > 1 then fprintf f ", ";
							fprintf f "a%d" i;
							succ i
						) 1 nt in
						fprintf f " = v in";
						pp_sequence nt
					| _ -> assert false
					end;
					fprintf f "@]"
				) in
				fprintf f "@,@[<hv2>@[<b4>let pp_option@ (pp_value: Format.formatter -> 'v -> unit)@ ";
				fprintf f "~(paren: bool)@ ";
				fprintf f "(f: Format.formatter)@ (r: 'v option) =@]@,";
				fprintf f "@[match @[r@]@ with@]";
				fprintf f "@;<1 2>@[<b2>@[<hov-2>Some a ->@]@ @[<hv>";
				fprintf f "Format.pp_open_box f 2;@,";
				fprintf f "if paren then Format.pp_print_string f \"(\";@,";
				fprintf f "Format.pp_print_string f \"Some\";@,";
				fprintf f "Format.pp_print_space f ();@,";
				fprintf f "pp_value f a;@,";
				fprintf f "if paren then Format.pp_print_string f \")\";@,";
				fprintf f "Format.pp_close_box f ();@]@]";
				fprintf f "@ | @[<b2>@[<hov-2>None ->@]@ @[<hv>";
				fprintf f "Format.pp_print_string f \"None\";;@]@]@]@,";
				if !ranged_position then (
					fprintf f "@,@[<hv2>@[<b4>let pp_position_pair@ (pp_position: Format.formatter -> 'p -> unit)@ ";
					fprintf f "(f: Format.formatter)@ ((first, last): 'p * 'p) =@]@,";
					fprintf f "Format.pp_open_box f 2;@,";
					fprintf f "Format.pp_print_char f \'(\';@,";
					fprintf f "pp_position f first;@,";
					fprintf f "Format.pp_print_char f \',\';@,";
					fprintf f "Format.pp_print_space f ();@,";
					fprintf f "pp_position f last;@,";
					fprintf f "Format.pp_print_char f \')\';@,";
					fprintf f "Format.pp_close_box f ();;@]@,"
				);
				let (none, _: bool * Typing.t list) = List.fold_left (fun ((first, done_types) as loop_vars) e ->
					begin match e with
					| `element _ | `epsilon | `position | `option _ ->
						loop_vars
					| `tuple _ | `variant _ ->
						process first e;
						false, e :: done_types
					end
				) (true, []) ts in
				if not none then fprintf f ";;@]@,"
			);;
			
			let output_result_pretty_printer (f: formatter) (result_type: Typing.t) = (
				fprintf f "@ let pp_result = ";
				output_printer_name f result_type;
				fprintf f ";;@,"
			);;
			
			let output_debug (f: formatter) (): unit = (
				fprintf f "@,let debug = ref false;;@,"
			);;
			
			let output_value_ctorname (f: formatter) (t: Typing.t): unit = (
				fprintf f "Value_";
				match t with
				| `element _ -> fprintf f "elt"
				| _ -> output_ctorname f t
			);;
			
			let output_alphabet_type_decl (f: formatter) (alphabet: Token.t list): unit = (
				fprintf f "@,@[type alphabet = @[%a@];;@]@,"
					(Token.pp_typename ~quali:true ~paren:false) alphabet
			);;
			
			let output_alphabet_typename (f: formatter) (token_is_pv: bool): unit = (
				if token_is_pv then (
					fprintf f "alphabet"
				) else (
					Token.pp_typename ~paren:false ~quali:true f []
				)
			);;
			
			let output_downcast_types (f: formatter) (types: Typing.t list): unit = (
				if not (
					List.fold_left (fun first t ->
						begin match t with
						| `element ("", {contents = unique}, {contents = tokens}) when unique > 0 ->
							fprintf f "@,@[type elt%d = %a;;@]"
								unique
								(Token.pp_typename ~quali:true ~paren:false) (TokenSet.elements tokens);
							false
						| _ ->
							first
						end
					) true types
				) then fprintf f "@,"
			);;
			
			let output_value_type (f: formatter)
				(token_is_pv: bool)
				(map: (tree * Typing.t) list)
				(types: Typing.t list): unit =
			(
				fprintf f "@,@[<hv2>type ";
				output_single_position_typename f ();
				fprintf f " value =";
				let (_: bool) = List.fold_left (fun first t ->
					if not (List.exists (fun (_, i) -> i == t) map) ||
						(token_is_pv && match t with `element _ -> true | _ -> false)
					then (
						first
					) else (
						if first then (
							fprintf f "@,@[<b4>@;<2 0>"
						) else (
							fprintf f "@,@[<b4>| "
						);
						output_value_ctorname f t;
						if t <> `epsilon then (
							fprintf f " of@ %a" (output_typename ~option:true) t
						);
						fprintf f "@]";
						false
					)
				) true types in
				if token_is_pv then (
					fprintf f "@,@[<b4>| Value_elt of@ alphabet";
					if Token.invalid = None then fprintf f " option";
					fprintf f "@]"
				);
				fprintf f "@];;@,"
			);;
			
			let output_token_constants (f: formatter) (map: string TokenMap.t): unit = (
				if not (TokenMap.is_empty map) then (
					TokenMap.iter (fun token id ->
						fprintf f "@ let token_%s = @[%a@];;" id (Token.pp ~paren:false ~quali:true) token
					) map;
					fprintf f "@,"
				)
			);;
			
			let output_expected_tag ~(optional: bool) (f: formatter) (t: Typing.t): unit = (
				fprintf f "Expected_";
				if optional then fprintf f "optional_";
				fprintf f "%s" (
					match Typing.first_type_for_error t with
					| `element (name, _, _) | `tuple (name, _) | `variant (name, _) -> name
					| `position -> "position"
					| `epsilon -> "epsilon"
					| `option _ -> assert false)
			);;
			
			let output_error_type (f: formatter)
				~(unexpected_terminals: Token.t list)
				~(unexpected_nonterminals: string list)
				~(expected_terminals: Token.t list)
				~(expected_nonterminals: (Typing.t * bool) list): unit =
			(
				fprintf f "@ @[<hv2>type error =@;<1 2>Unexpected of %a" (Token.pp_typename ~paren:false ~quali:true) unexpected_terminals;
				List.iter (fun name ->
					fprintf f "@ | Unexpected_%s" name
				) unexpected_nonterminals;
				if expected_terminals <> [] then (
					fprintf f "@ | Expected of %a list" (Token.pp_typename ~paren:true ~quali:true) expected_terminals
				);
				List.iter (fun (t, optional) ->
					fprintf f "@ | ";
					output_expected_tag ~optional f t
				) expected_nonterminals;
				fprintf f ";;@]@,"
			);;
			
			let output_error_printer (f: formatter)
				(token_is_pv: bool)
				~(alphabet: Token.t list)
				~(unexpected_nonterminals: string list)
				~(expected_terminals: Token.t list)
				~(expected_nonterminals: (Typing.t * bool) list): unit =
			(
				fprintf f "@ @[<hv2>let pp_list @[(pp_elt: Format.formatter -> 'a -> unit)@ (f: Format.formatter)@ (xs: 'a list): unit =@]";
				fprintf f "@ @[<hv2>let rec loop first xs =";
				fprintf f "@ @[<hv>match xs with";
				fprintf f "@;<1 2>x :: xr -> ";
				fprintf f "@[<hv>if not first then (@[Format.pp_print_char f ';';@ Format.pp_print_space f ()@]);";
				fprintf f "@ pp_elt f x;";
				fprintf f "@ loop false xr@]";
				fprintf f "@ | [] -> ()";
				fprintf f "@]@]@ in@ Format.pp_print_char f '[';";
				fprintf f "@ Format.pp_open_box f 0;";
				fprintf f "@ loop true xs;";
				fprintf f "@ Format.pp_close_box f ();";
				fprintf f "@ Format.pp_print_char f ']'";
				fprintf f "@];;@,";
				fprintf f "@ @[<hv2>let pp_error ";
				fprintf f "@[(pp_elt: Format.formatter -> %a -> unit)" output_alphabet_typename token_is_pv;
				fprintf f "@ (f: Format.formatter)";
				fprintf f "@ (e: error): unit =@]@ ";
				fprintf f "@[<hv>match e with";
				fprintf f "@;<1 2>Unexpected x -> @[";
				fprintf f "Format.pp_print_string f \"Unexpected \";@ pp_elt f x@]";
				List.iter (fun name ->
					fprintf f "@ | Unexpected_%s -> " name;
					fprintf f "Format.pp_print_string f \"Unexpected_%s\"" name
				) unexpected_nonterminals;
				fprintf f "@ | Expected xs -> @[";
				fprintf f "Format.pp_print_string f \"Expected \";@ pp_list pp_elt f ";
				let downcast = Typing.string_of_token_typename expected_terminals <> Typing.string_of_token_typename alphabet in
				if downcast then fprintf f "(";
				fprintf f "xs";
				if downcast then fprintf f ":> %a list)" output_alphabet_typename token_is_pv;
				fprintf f "@]";
				List.iter (fun (t, optional) ->
					fprintf f "@ | %a -> Format.pp_print_string f \"%a\""
						(output_expected_tag ~optional) t
						(output_expected_tag ~optional) t;
				) expected_nonterminals;
				fprintf f "@]@];;@,"
			);;
			
			let output_stack_type (f: formatter) (token_is_pv: bool): unit = (
				fprintf f "@ @[<hv2>type %a stack_item = {" output_single_position_typename ();
				fprintf f "@,position: %a;" (output_position_typename ~paren:false) ();
				fprintf f "@ value: %a value;" output_single_position_typename ();
				fprintf f "@ goto_f: int -> %a -> %a -> %a t -> %a t"
					(output_position_typename ~paren:false) ()
					output_alphabet_typename token_is_pv
					output_single_position_typename ()
					output_single_position_typename ();
				fprintf f "}@]@,@[<hv2>and %a t = {" output_single_position_typename ();
				fprintf f "@,state_f: %a -> %a -> %a t -> %a t;"
					(output_position_typename ~paren:false) ()
					output_alphabet_typename token_is_pv
					output_single_position_typename ()
					output_single_position_typename ();
				fprintf f "@ stack: %a stack_item list;" output_single_position_typename ();
				fprintf f "@ errors: (%a * error) list;" (output_position_typename ~paren:true) ();
				fprintf f "@ accepted: bool";
				if !runtime_debug then fprintf f ";@ mutable path: (int * int) list";
				fprintf f "};;@]@,"
			);;
			
			let output_state_handlers ~(pp_nonterminal: Format.formatter -> int -> unit)
				(f: formatter)
				(token_is_pv: bool)
				(token_id_map: string TokenMap.t)
				(table: Lalr1.table): unit =
			(
				if !runtime_debug then (
					fprintf f "@ @[<hv2>let state_debug (p: 'p t) (no: int): unit =@ ";
					fprintf f "prerr_string \"state_\";@ ";
					fprintf f "prerr_int no;@ ";
					fprintf f "prerr_newline ();@ ";
					fprintf f "let depth = List.length p.stack in@ ";
					fprintf f "@[<hv2>if List.exists (fun (n, d) -> n = no && d <= depth) p.path then@ raise (Failure (\"state_\" ^ string_of_int no));@]@ ";
					fprintf f "p.path <- (no, depth) :: p.path;;@]@,"
				);
				let states = Lalr1.states table in
				let goto_error_required = ref false in
				let none = Array.fold_left (fun first i ->
					(* state_X *)
					if first then (
						fprintf f "@ @[<hv2>let rec"
					) else (
						fprintf f "@,@[<hv2>and"
					);
					fprintf f " state_%d " (Lalr1.no i);
					fprintf f "(position: %a) " (output_position_typename ~paren:false) ();
					fprintf f "(token: %a) " output_alphabet_typename token_is_pv;
					fprintf f "(p: %a t) " output_single_position_typename ();
					fprintf f ":%a t =@ " output_single_position_typename ();
					if !runtime_debug then (
						fprintf f "(* %a *)@ " (Lalr1.pp_core_set ~pp_nonterminal (Lalr1.rules table)) (Lalr1.core_set i);
						fprintf f "if !debug then state_debug p %d;@ " (Lalr1.no i)
					);
					fprintf f "@[match @[token@]@ with@]";
					let generate action (tokens, error_tokens, otherwise) first = (
						(* tokens *)
						let output_pattern otherwise j pattern_first = (
							if pattern_first && first then (
								fprintf f "@;<1 2>@[<b2>@[<hov-2>"
							) else if pattern_first then (
								fprintf f "@ | @[<b2>@[<hov-2>"
							) else (
								fprintf f "@ | "
							);
							if not otherwise then (
								Token.pp_pattern ~quali:true ~paren:false f j
							) else (
								fprintf f "_"
							);
							false
						) in
						if otherwise then (
							let (_: bool) = output_pattern true Token.eof true in
							if !runtime_debug then (
								fprintf f "@ (*";
								let (_: bool) = Lalr1.TokenSet.fold (output_pattern false) tokens true in
								fprintf f "@]@] *)"
							)
						) else (
							let pattern_first = Lalr1.TokenSet.fold (output_pattern false) tokens true in
							let (_: bool) = Lalr1.TokenSet.fold (output_pattern false) error_tokens pattern_first in ()
						);
						fprintf f " ->@]@ @[<hv>";
						begin match action with
						| Lalr1.Shift dest_index | Lalr1.ErrorShiftTerminal (_, dest_index) | Lalr1.ErrorShiftNonterminal (_, _, _, dest_index) ->
							(* shift *)
							fprintf f "(* ";
							begin match action with
							| Lalr1.ErrorShiftTerminal _ | Lalr1.ErrorShiftNonterminal _ ->
								fprintf f "error - "
							| _ -> ()
							end;
							fprintf f "shift *)@ ";
							if !ranged_position then (
								begin match action with
								| Lalr1.ErrorShiftTerminal _ | Lalr1.ErrorShiftNonterminal _ ->
									fprintf f "let position = let f, _ = position in f, f in@ "
								| _ -> ()
								end
							);
							fprintf f "@[<b2>";
							begin match action with
							| Lalr1.ErrorShiftTerminal _ | Lalr1.ErrorShiftNonterminal _ ->
								fprintf f "state_%d position token " dest_index
							| Lalr1.Shift _ -> ()
							| _ -> assert false
							end;
							fprintf f "{p with@ @[";
							begin match action with
							| Lalr1.ErrorShiftTerminal (es, _) ->
								fprintf f "errors = @[(@[position,@ Expected [@[";
								let _ = Lalr1.TokenSet.fold (fun e first ->
									if not first then fprintf f "; ";
									fprintf f "token_%s" (TokenMap.find e token_id_map);
									false
								) es true in
								fprintf f "@]]@]) ::@ p.errors;@]@ "
							| Lalr1.ErrorShiftNonterminal (_, SemanticAction.PositionAt, _, _) -> ()
							| Lalr1.ErrorShiftNonterminal (es, sa, optional, _) ->
								fprintf f "errors = @[(@[position,@ ";
								let ft = Typing.first_type_for_error (SemanticAction.get_type sa) in
								begin match ft with
								| `element _ ->
									fprintf f "Expected [@[";
									let _ = Lalr1.TokenSet.fold (fun e first ->
										if not first then fprintf f "; ";
										fprintf f "token_%s" (TokenMap.find e token_id_map);
										false
									) es true in
									fprintf f "@]]"
								| _ ->
									output_expected_tag ~optional f ft
								end;
								fprintf f "@]) ::@ p.errors;@]@ "
							| Lalr1.Shift _ -> ()
							| _ -> assert false
							end;
							fprintf f "stack = @[{@[position = position;@ value = ";
							begin match action with
							| Lalr1.ErrorShiftNonterminal (_, sa, _, _) ->
								begin match sa with
								| SemanticAction.Token t
								| SemanticAction.Itself (t, _)
								| SemanticAction.Tuple (t, _)
								| SemanticAction.Variant (t, _, _) ->
									output_value_ctorname f t;
									if t <> `epsilon then fprintf f " None"
								| SemanticAction.PositionAt | SemanticAction.PositionWith (`position, _) ->
									output_value_ctorname f `position;
									fprintf f " position"
								| SemanticAction.PositionWith (t, _) ->
									output_value_ctorname f t;
									fprintf f " (position, None)"
								| SemanticAction.Any _ ->
									assert false
								end
							| Lalr1.ErrorShiftTerminal _ ->
								fprintf f "Value_elt ";
								begin match Token.invalid with
								| Some iv ->
									Token.pp ~quali:true ~paren:true f iv
								| None ->
									fprintf f "None"
								end
							| Lalr1.Shift _ ->
								fprintf f "Value_elt ";
								if Token.invalid = None then fprintf f "(Some ";
								fprintf f "token";
								if Token.invalid = None then fprintf f ")"
							| _ -> assert false
							end;
							fprintf f ";@ goto_f = goto_";
							if Lalr1.SymbolMap.is_empty (Lalr1.goto_table states.(Lalr1.no i)) then (
								fprintf f "error";
								goto_error_required := true
							) else (
								fprintf f "%d" (Lalr1.no i)
							);
							fprintf f "@]} ::@ p.stack@];@ ";
							fprintf f "state_f = state_%d" dest_index; (* new state *)
							fprintf f "@]}@]"
						| Lalr1.Reduce (base, sa, nonterminal_index) | Lalr1.ErrorReduce (base, sa, nonterminal_index) ->
							(* reduce *)
							fprintf f "(* reduce %a *)@ " SemanticAction.pp sa;
							let indexes = SemanticAction.get_indexes sa in
							let output_body () = (
								let goto_f = (
									if base > 0 then (
										"goto_f"
									) else (
										"goto_" ^ string_of_int (Lalr1.no i)
									)
								) in
								let reduce_position = (
									if base = 0 then (
										"position"
									) else if !ranged_position && base > 1 then (
										"range_position"
									) else (
										"p0"
									)
								) in
								if !ranged_position && base > 1 then (
									fprintf f "let f, _ = p0 in@ ";
									fprintf f "let _, l = p%d in@ " (base - 1);
									fprintf f "let range_position = (f, l) in@ "
								);
								fprintf f "let new_state = %s %d in@ " goto_f nonterminal_index;
								fprintf f "@[<b2>new_state position token {p with@ @[";
								begin match sa with
								| SemanticAction.Variant (_, ctor, _) when is_error ctor ->
									fprintf f "errors = (%s, Unexpected_%s) :: p.errors;@ " reduce_position (extract_error_name ctor)
								| _ -> ()
								end;
								fprintf f "stack = @[{@["; (* reduced value *)
								fprintf f "position = %s;@ " reduce_position;
								fprintf f "value = ";
								let rec output_indexes f indexes i base first = (
									let f2 = (
										if List.mem_assoc i indexes then (
											if not first then fprintf f ", ";
											let (gp, vt) = List.assoc i indexes in
											if not gp then (
												fprintf f "x%d" i
											) else if vt = `position then (
												fprintf f "p%d" i
											) else (
												fprintf f "(p%d, x%d)" i i
											);
											false
										) else (
											first
										)
									) in
									if i < base then (
										output_indexes f indexes (i + 1) base f2
									)
								) in
								begin match sa with
								| SemanticAction.Token _ ->
									fprintf f "v0"
								| SemanticAction.PositionAt ->
									if !ranged_position then (
										fprintf f "(@[let f, _ = position in@ ";
										output_value_ctorname f `position;
										fprintf f "@ (f, f)@])" (* first..first *)
									) else (
										fprintf f "%a @[position@]" output_value_ctorname `position
									)
								| SemanticAction.PositionWith (`position, _) ->
									output_value_ctorname f `position;
									if !ranged_position && base > 1 then (
										fprintf f "@ (f,@ l)"
									) else (
										fprintf f "@ p0"
									)
								| SemanticAction.PositionWith (t, _) ->
									output_value_ctorname f t;
									fprintf f "@ (p0,@ x0)"
								| SemanticAction.Tuple (t, _) ->
									fprintf f "@[%a" output_value_ctorname t;
									if indexes <> [] then (
										fprintf f "@ (@[Some@ (";
										output_indexes f indexes 0 base true;
										fprintf f ")@])"
									);
									fprintf f "@]"
								| SemanticAction.Variant (t, ctor, _) ->
									fprintf f "%a " output_value_ctorname t;
									if is_error ctor then (
										fprintf f "None"
									) else (
										fprintf f "(@[Some@ ";
										if indexes <> [] then (
											fprintf f "("
										);
										fprintf f "%s" (String.capitalize ctor);
										if indexes <> [] then (
											fprintf f "@ ";
											let indexes_length = List.length indexes in
											if indexes_length > 1 then fprintf f "(@[";
											output_indexes f indexes 0 base true;
											if indexes_length > 1 then fprintf f ")@]";
											fprintf f ")"
										);
										fprintf f ")@]"
									)
								| SemanticAction.Itself (_, idx) ->
									fprintf f "v%d" idx
								| SemanticAction.Any _ ->
									output_value_ctorname f `epsilon
								end;
								fprintf f ";@ goto_f = %s" goto_f;
								fprintf f "} ::@]@ ";
								if base > 0 then (
									fprintf f "rest"
								) else (
									fprintf f "p.stack"
								);
								fprintf f "@];@ ";
								fprintf f "state_f = new_state";
								fprintf f "@]}@]"
							) in
							if base = 0 then (
								output_body ()
							) else (
								fprintf f "@[<hv2>begin@ ";
								fprintf f "@[match @[p.stack@]@ with@]";
								fprintf f "@;<1 2>@[<b2>@[<hov-2>@[";
								for k = base - 1 downto 0 do
									let need_value = List.mem_assoc k indexes &&
										let (gp, vt) = List.assoc k indexes in not gp || vt <> `position
									in
									let need_position = k = 0 || (!ranged_position && k = base - 1) || (
										List.mem_assoc k indexes && 
										let (gp, _) = List.assoc k indexes in gp
									) in
									let need_goto = k = 0 in
									if need_value || need_position then (
										fprintf f "{@[";
										if need_value then (
											fprintf f "value = ";
											begin match sa with
											| SemanticAction.Token _
											| SemanticAction.PositionAt
											| SemanticAction.Any _
											| SemanticAction.Itself _ ->
												fprintf f "v%d" k
											| SemanticAction.PositionWith _
											| SemanticAction.Tuple _
											| SemanticAction.Variant _ ->
												let (_, t) = List.assoc k indexes in
												output_value_ctorname f t;
												begin match t with
												| `element ("", {contents = unique}, _) when unique > 0 ->
													fprintf f " (";
													if Token.invalid = None then fprintf f "(Some ";
													fprintf f "#elt%d" unique;
													if Token.invalid = None then fprintf f " | None)";
													fprintf f " as x%d)" k
												| _ ->
													fprintf f " x%d" k
												end
											end
										);
										if need_position then (
											if need_value then (
												fprintf f ";@ "
											);
											fprintf f "position = p%d" k
										);
										if need_goto then (
											if need_value || need_position then (
												fprintf f ";@ "
											);
											fprintf f "goto_f = goto_f"
										);
										fprintf f "} ::@]@ "
									) else (
										fprintf f "_ ::@ "
									)
								done;
								fprintf f "rest@] ->@]@ @[<hv>";
								output_body ();
								fprintf f "@]@]@ | @[<b2>@[<hov-2>_ ->@]@ @[<hv>";
								fprintf f "assert false";
								fprintf f "@]@]@]@ end"
							)
						| Lalr1.Accept ->
							(* accept *)
							fprintf f "(* accept *)@ ";
							fprintf f "{p with accepted = true}"
						end;
						fprintf f "@]@]"
					) in
					let action_table = Lalr1.action_table i in
					let otherwise_action = Lalr1.otherwise_action i in
					let map = Lalr1.Compaction.unify action_table otherwise_action in
					if Lalr1.Compaction.iter generate map then (
						fprintf f "@ | @[<b2>@[<hov-2>_ ->@]@ @[<hv>(* error *)@ ";
						fprintf f "{p with errors = (position, Unexpected token) :: p.errors}@]@]"
					);
					(* goto_X *)
					let goto_table = Lalr1.goto_table i in
					if not (Lalr1.SymbolMap.is_empty goto_table) then (
						fprintf f "@]@ @[<hv2>@[<b4>and goto_%d" (Lalr1.no i);
						fprintf f "@ (nonterminal_index: int):";
						fprintf f "@ %a -> %a -> %a t -> %a t =@]"
							(output_position_typename ~paren:false) ()
							output_alphabet_typename token_is_pv
							output_single_position_typename ()
							output_single_position_typename ();
						let none = Array.fold_left (fun first r_left ->
							let nonterminal_index = (
								match r_left with
								| Lalr1.Nonterminal i -> i
								| _ -> assert false
							) in
							begin try
								let k = Lalr1.SymbolMap.find r_left goto_table in
								if first then (
									fprintf f "@,@[match @[nonterminal_index@]@ with@]@;<1 2>"
								) else (
									fprintf f "@ | "
								);
								fprintf f "@[<b2>@[<hov-2>%d ->@]@ @[<hv>" nonterminal_index;
								fprintf f "state_%d@]@]" k;
								false
							with
							| Not_found -> first
							end
						) true (Lalr1.nonterminals table) in
						if not none then (
							fprintf f "@ | @[<b2>@[<hov-2>_ ->@]@ @[<hv>assert false@]@]"
						) else (
							fprintf f "assert false"
						)
					);
					fprintf f "@]";
					false
				) true states in
				if not none then (
					if !goto_error_required then (
						fprintf f "@,@[<hv2>@[<b4>and goto_error";
						fprintf f "@ (nonterminal_index: int):";
						fprintf f "@ %a -> %a -> %a t -> %a t =@]"
							(output_position_typename ~paren:false) ()
							output_alphabet_typename token_is_pv
							output_single_position_typename ()
							output_single_position_typename ();
						fprintf f "@,assert false@]"
					);
					fprintf f ";;@,"
				)
			);;
			
			let output_create (f: formatter) (start_state: int) = (
				fprintf f "@ @[<hv2>let create (): %a t = {" output_single_position_typename ();
				fprintf f "@[state_f = state_%d;@ stack = [];@ errors = [];@ accepted = false" start_state;
				if !runtime_debug then fprintf f ";@ path = []";
				fprintf f "@]};;@]@,"
			);;
			
			let output_post (f: formatter) (token_is_pv: bool) = (
				fprintf f "@ @[<hv2>let post";
				fprintf f " (position: %a)" (output_position_typename ~paren:false) ();
				fprintf f " (token: %a)" output_alphabet_typename token_is_pv;
				fprintf f " (p: %a t)" output_single_position_typename ();
				fprintf f ": %a t =@ " output_single_position_typename ();
				if !runtime_debug then fprintf f "p.path <- [];@ ";
				fprintf f "p.state_f position token p@];;@,"
			);;
			
			let output_accepted (f: formatter) () = (
				fprintf f "@ let accepted (p: %a t): bool = p.accepted;;@," output_single_position_typename ()
			);;
			
			let output_result (f: formatter) (result_type: Typing.t) = (
				fprintf f "@ @[<hv2>@[<b4>let result (p: %a t):@ %a"
					output_single_position_typename ()
					(output_typename ~option:true) result_type;
				fprintf f " =@]@ ";
				fprintf f "assert p.accepted;@,";
				fprintf f "@[match @[p.stack@]@ with@]";
				fprintf f "@;<1 2>@[<b2>@[<hov-2>{value = %a r} :: _ ->@]@ @[<hv>r@]@]"
					output_value_ctorname result_type;
				fprintf f "@ | @[<b2>@[<hov-2>_ ->@]@ @[<hv>assert false;;@]@]@]@,"
			);;
			
			let output_errors (f: formatter) () = (
				fprintf f "@ let errors (p: %a t): (%a * error) list = p.errors;;@,"
					output_single_position_typename ()
					(output_position_typename ~paren:true) ()
			);;
			
		end;;
		
	end;;
	open Private;;
	
	(** Generate your parser. *)
	let pp_generate (f: Format.formatter)
		?(ast_module: string = "") ?(parser_module: string = "") (p: parser): unit =
	(
		let error_report ~(pp_nonterminal: Format.formatter -> int -> unit) (count: int ref)
			(message: string) (x: Lalr1.rule) (y: Lalr1.rule): unit =
		(
			incr count;
			let pp_rule = Lalr1.pp_rule ~pp_nonterminal ?star:None ?typed:None in
			Format.fprintf Format.err_formatter "error: %s: (%a vs %a)@." message pp_rule x pp_rule y
		) in
		(* write header *)
		let ps = node_list p in
		let alphabet = alphabet ps in
		Writer.output_header f alphabet;
		(* types *)
		let (types, type_of_node_map) = Typing.types_of_parser ps in
		let result_type = List.assq (Lazy.force p) type_of_node_map in
		(* write abstract data type module *)
		if ast_module <> "" then (
			Writer.begin_module f (String.capitalize ast_module)
		);
		Writer.output_result_types f types;
		if !pretty_printer then (
			Writer.output_pretty_printer f alphabet types;
			Writer.output_result_pretty_printer f result_type
		);
		if ast_module <> "" && ast_module <> parser_module then (
			Writer.end_module f ()
		);
		(* parser *)
		let rules, nonterminal_names = rules_of_parser p type_of_node_map in
		let pp_nonterminal f i = Format.fprintf f "%s" (Array.get nonterminal_names i) in
		let conflicted_count = ref 0 in
		let table = Lalr1.create ~pp_nonterminal Format.err_formatter
			~debug:!debug ~error_handling:!error_handling
			~shift_reduce_conflict:(error_report ~pp_nonterminal conflicted_count "shift/reduce conflict")
			~reduce_reduce_conflict:(error_report ~pp_nonterminal conflicted_count "reduce/reduce conflict")
			rules
		in
		let start_state = Lalr1.start_state table in
		let expected_terminals, expected_nonterminals = correct_symbols_on_error table in
		let expected_terminal_map = identifiers_of_alphabet expected_terminals in
		let unexpected_nonterminals = correct_bad_names rules in
		(* write parser module *)
		if ast_module <> parser_module then (
			if parser_module <> "" then (
				Writer.begin_module f (String.capitalize parser_module)
			);
			if ast_module <> "" then (
				Writer.open_module f (String.capitalize ast_module)
			)
		);
		if !runtime_debug then Writer.output_debug f ();
		let token_is_pv = Typing.is_polymorphic_variant alphabet in
		if token_is_pv then (
			Writer.output_alphabet_type_decl f alphabet;
			Writer.output_downcast_types f types
		);
		Writer.output_value_type f token_is_pv type_of_node_map types;
		Writer.output_token_constants f expected_terminal_map;
		Writer.output_error_type f
			~unexpected_terminals:alphabet ~unexpected_nonterminals
			~expected_terminals ~expected_nonterminals;
		if !error_printer then (
			Writer.output_error_printer f token_is_pv
				~alphabet
				~unexpected_nonterminals
				~expected_terminals ~expected_nonterminals
		);
		Writer.output_stack_type f token_is_pv;
		Writer.output_state_handlers ~pp_nonterminal f token_is_pv expected_terminal_map table;
		Writer.output_create f start_state;
		Writer.output_post f token_is_pv;
		Writer.output_accepted f ();
		Writer.output_result f result_type;
		Writer.output_errors f ();
		if parser_module <> "" then (
			Writer.end_module f ()
		);
		(* write footer *)
		Writer.output_footer f ();
		(* conflicting as error *)
		if !conflicting_error && !conflicted_count > 0 then (
			raise (ParserGeneratingError (string_of_int !conflicted_count ^ " conflicting was/were found."))
		);
		(* infinity loop check *)
		if !debug then (
			let loops = Lalr1.check alphabet table in
			if loops <> [] then (
				List.iter (fun (state, token) ->
					Format.eprintf "@[at@ %a,@ %a@ will@ cause@ infinity@ loop.@]@."
						(pp_list Format.pp_print_int) state
						(Token.pp_pattern ~paren:false ~quali:false) token
				) loops;
				raise (ParserGeneratingError (string_of_int (List.length loops) ^ " loop pattern(s) was/were found."))
			)
		)
	);;

	(** Generate and output your parser. *)
	let generate = pp_generate Format.std_formatter;;
end;;

(** For using char as token, Normal implementation to instance ParserGenerator module. *)
module CharToken = struct

	type t = char;;

	(** The character ['\x1a'] means end of file. *)
	let eof: char = '\x1a';;

	(** No character be used to report error. *)
	let invalid: char option = None;;

	let pp ~(quali: bool) ~(paren: bool) (f: Format.formatter) (e: char): unit = (
		Format.pp_print_char f '\'';
		Format.pp_print_string f (Char.escaped e);
		Format.pp_print_char f '\''
	);;

	let pp_pattern = pp;;

	let pp_typename ~(quali: bool) ~(paren: bool) (f: Format.formatter) (_: char list): unit = (
		Format.pp_print_string f "char"
	);;

	let compare = Char.compare;;
end;;
